package Firepear::Carrot::Lexer;
use Firepear::Carrot::Util;

use warnings;
use strict;

use Digest::MD5 qw(md5_hex);

=head1 NAME

Firepear::Carrot::Lexer - Turn files into a stream of tokens

=head1 VERSION

Version 1.000

=cut

our $VERSION = '1.000';

=head1 SYNOPSIS

    use Firepear::Carrot::Lexer;

    my $l = Firepear::Carrot::Lexer->new( files => \@filelist );

    until ($l->status == 99) {
      my $token = $l->fetch;
      ERROR_HANDLER($l->status, $l->fileinfo)
          if ($token eq undef);
      TOKEN_HANDLER($token);
    }

=head1 DESCRIPTION

The Lexer turns a one or more files (or scalars treated as files) into
a stream of tokens. A token is always one of the following:

=over

=item

A single newline

=item

Any number of consecutive whitespace characters

=item

Any number of consecutive non-whitespace characters

=back

With one exception: when a file other than the last file being
tokenized ends, two newlines (C<\n\n>) will be returned, ensuring that
file breaks to be seen as paragraph breaks.



=head1 CONSTRUCTOR AND UTILITY METHODS

=head2 new

Expects one argument, an arrayref of files to be tokenized.

In the simplest case, this will be a simple list of actual filenames.

    ['file.1', 'file.2', 'file.3']

But the Lexer can also process scalar values as if they were
files. This requires some arguments to let the Lexer know what's up.

    [ 'file.1',
      { name   => 'chunk1',
        scalar => 1,
        text   => "Lorem ipsum dolor sit amet, consectetur" },
      'file.2' ]

Actual files can be specified this way as well:

    [ { name   => 'file.1',
        scalar => 0 },
      { name   => 'file.2',
        scalar => 0 },
      { name   => 'string.1',
        scalar => 1,
        text   => "adipisicing elit, sed do eiusmod tempor" } ]

=cut

sub new {
    my ($class,%args) = @_;

    my $self = bless { f => { idx    => -1,
			      handle => undef,
			      line   => [], },
                       l => { char => 0,
			      type => 0, },
                       t => { tok  => '',
			      type => 0,
			      next => [],
			      prev => "\n", },
                       s => 0,
                     }, $class;

    # no files; return error flag instead of object
    unless (defined $args{files}[0])
      { $self->status(901); return $self }

    # set up the file list
    foreach my $f ( @{$args{files}} ) {
	my %finfo = (pos   => 0,
		     line  => 1,
		     md5   => undef,
		     par   => 0,
		     pline => 0 );
	push @{$self->{f}{list}}, filehash($f, %finfo);
    }

    # and prep the first file
    $self->fopen;

    # then prime the lookahead pump
    $self->lookahead;

    return $self;
}

=head2 fileinfo

Returns a hashref of data about the file currently being
tokenized. Includes:

    * fnum  (number of file (order processed))
    * name  (filename)
    * pos   (position of read cursor in file)
    * lnum  (line number)
    * line  (current line,up to current token)
    * token (current token)
    * par   (name of parent file)
    * pline (linecount from parent file)

This combined with the L</status> yields the complete state of the
tokenizer at the present time.

=cut

sub fileinfo {
    my ($self) = @_;
    my $fnum = $self->{f}{idx};

    return { fnum  => $fnum + 1,
	     name  => $self->{f}{list}[$fnum]{name},
	     pos   => $self->{f}{list}[$fnum]{pos},
	     lnum  => $self->{f}{list}[$fnum]{line},
	     line  => $self->{f}{line},
	     token => $self->{t}{tok},
	     par   => $self->{f}{list}[$fnum]{par},
	     pline => $self->{f}{list}[$fnum]{pline},
           }
}

=head2 settoken

Manually adjusts current/prev/next token. Returns the new current
token.

    $l->settoken(cur  => $token,
                 prev => $ptoken,
                 next => $ntoken);

A new current token must be set. The C<prev> and C<next> tokens are
optional.

This should only be used by higher-level parsing routines which need
to split tokens into subtokens and then continue processing with some
part of the original token in its place (like the comment handler).

There is no validity checking of any sort; for the love of all that is
holy, use this sparingly and judiciously.

=cut

sub settoken {
    my ($self,%toks) = @_;
    return undef unless defined $toks{cur};

    $self->{t}{prev} = $toks{prev} if defined $toks{prev};
    $self->{t}{tok} = $toks{cur};
    if (defined $toks{next}) {
	push @{$self->{t}{next}}, $toks{next};
	# change status if at EOD so fetch will catch it
	$self->status(1) if ($self->status == 99);
    }
    return $toks{cur};
}

=head2 filehash

Breaks down filelist elements and puts them back together in a hash
for L</new> and L</fpush>.

=cut

sub filehash {
    my ($file, %fhash) = @_;

    if (ref $file eq 'HASH') {
	$fhash{name}   =   $file->{name};
	$fhash{scalar} = ( $file->{scalar} ? 1 : 0);
	$fhash{text}   = ( $file->{text}   ? $file->{text} : undef);
    } else {
	$fhash{name}   = $file;
	$fhash{scalar} = 0;
    }
    return \%fhash;
}



=head1 TOKENIZING METHODS

=head2 fetch

By default, returns the next token from the input stream. Returns
undef if a token cannot be read.

Accepts a single argument, which can be:

=over

=item C<current>

Returns the most recently assembled token.

=item C<prev>

Returns the token prior to the current one

=item C<line>

Returns an arrayref of all tokens on the current line, up to the
current token

=item C<next>

Returns the next token from the current input stream. Same as no
argument.

=back


=cut

sub fetch {
    my ($self) = @_;
    # return undef if we're at EOD and there are no {t}{next} is empty
    return undef if ($self->status >= 99);

    # lookahead() will have already gotten the next character unless
    # we're fetching the first token, in which case we're pulling
    # the values from new()
    my $ttype = $self->{t}{type};
    my $ltype = $self->{l}{type};

    # newlines are always complete tokens
    if ($ltype == 1 and scalar @{$self->{t}{next}} == 0) {
	$self->newline_handler;
	return $self->{t}{tok};
    }

    # post-process previous token
    $self->{t}{prev} = $self->{t}{tok}
      unless $self->{t}{tok} eq '';
    $self->{t}{tok} = '';
    $self->{t}{type} = $self->{l}{type};

    # build new token (or pop preset next)
    if (scalar @{ $self->{t}{next} }) {
	$self->{t}{tok} = pop @{ $self->{t}{next} };
	$self->status(99)
	  if ($self->status == 1 and scalar @{ $self->{t}{next} } == 0);
    } else {
	while ($ltype == $self->{l}{type}) {
	    $self->{t}{tok} .= $self->{l}{char};
	    $self->lookahead;
	}
    }

    # push token onto fileinfo line
    push @{ $self->{f}{line} }, $self->{t}{tok}
      unless ($self->{t}{tok} eq "\n");

    return $self->{t}{tok};
}

=head2 current

Sugar for fetching the current token.

=cut

sub current { my ($self) = @_; return $self->{t}{tok}  }

=head2 prev

Sugar for fetching the previous token.

=cut

sub prev    { my ($self) = @_; return $self->{t}{prev} }

=head2 line

Sugar for fetching the current line.

=cut

sub line    { my ($self) = @_; return $self->{f}{line} }


=head2 lookahead

Attempts to get the next character from the input stream.

=cut

sub lookahead {
    my ($self) = @_;
    my $rc = undef; my $chr = undef;
    return undef if $self->status;

    # If a character can be read, its type is set based on whether it
    # is a newline, whitespace, or other, and the character is copied
    # to $self->{l}{char}.
    #
    # If a character cannot be read:
    #
    # * If the return code was undefined (indicating a read error)
    #   then status is set to 100, $self->{l}{type} is set to 999 to
    #   force fetch to exit, and lookahead returns.
    #
    # * If the return code from the call to read was zero (indicating
    #   EOF), then fopen is called and:
    #
    # * If the call was successful, the read character value is set to
    #   "\n" and the lookahead character is set to the synthetic value
    #   "\n\n" and processing continues normally.
    #
    # * If the call was unsuccessful (i.e. a status code has been
    #   set), the the lookahead char type is set to 0 in order to
    #   terminate the token-building loop in fetch.
    #
    # Finally, the position of the read cursor within the current file
    # is stored in the file list hash.

    # try to reach a character
    { no warnings; $rc = read $self->{f}{handle}, $chr, 1 }

    unless (defined $rc) # undefined (read error)
      { $self->status(100); $self->{l}{type} = 999; return }

    if ($rc == 0) { # zero, EOF
	$self->fopen;
	unless ($self->status) # status 0 (EOF, files remaining)
	  { $self->{l}{char}  = "\n\n"; $self->{l}{type} = 1; return }
	else # status other (EOF, file error)
	  { $self->{l}{type} = 0; return }
    }

    # set lookahead chartype and the char itself
    if ($chr eq "\n") {       # newline
	$self->{l}{type} = 1;
    } elsif ($chr =~ /\s/) {  # other whitespace
	$self->{l}{type} = 2;
	$self->{l}{char} = $chr;
    } else {                  # not whitespace
	$self->{l}{type} = 3;
	$self->{l}{char} = $chr;
    }

    # set new position within file (in bytes)
    $self->{f}{list}[$self->{f}{idx}]{pos} = tell $self->{f}{handle};
}

=head2 newline_handler

Performs the housekeeping needed when newlines are encountered in
document source files.

=cut

sub newline_handler {
    my ($self) = @_;

    if ($self->{l}{char} eq "\n\n") {
	# end-of-file synthetic para break
	$self->{t}{tok} = "\n";
	$self->{t}{prev} = "\n";
    } else {
	# plain old newline. set token and incrment line count
	$self->{t}{prev} = $self->{t}{tok}
	  unless $self->{t}{tok} eq '';
	$self->{t}{tok} = "\n";
	$self->{f}{list}[$self->{f}{idx}]{line}++;
    }

    $self->lookahead; # this may fail, but the next fetch call will
                      # take care of it
    $self->{f}{line}  = [];
}



=head1 FILE HANDLING METHODS

=head2 fopen

Opens the next file in the filelist. Sets a status code if a file
cannot be opened.

=cut

sub fopen {
    my ($self) = @_;
    my $filelist = $self->{f}{list};

    # shutdown filehandle if one has been opened
    close $self->{f}{handle} if (defined $self->{f}{handle} and 
				 ($filelist->[$self->{f}{idx}]{scalar} or 
				  fileno($self->{f}{handle}) > 0));
    # and move filelist pointer
    $self->{f}{idx}++;
    $self->{f}{idx} = @{$filelist} if ( $self->{f}{idx} > @{$filelist});
    my $idx = $self->{f}{idx};

    # if the file index pointer == filelist (scalar), we're out of files
    if ($idx == @{$filelist}) {
	my $status = (scalar @{$self->{t}{next}}) ? 1 : 99;
	$self->status($status);
	return;
    }

    # if not, fetch the new name and is-a-real-file value
    my $filename = $filelist->[$idx]{name};
    my $scalar   = $filelist->[$idx]{scalar};

    unless ($scalar) {
	# test file statues
	$self->status(103) unless (-f $filename);
	$self->status(102) unless (-r $filename);
	$self->status(101) unless (-e $filename);
    } else {
	# make sure there's something to read if we're not a file
	$self->status(104) unless (defined $filelist->[$idx]{text});
    }
    return if $self->status;

    # check for dupes
    $self->status(105) if $self->fdupecheck($filename, $filelist);
    return if $self->status;

    # everything looks okay, so open it up
    if ($scalar) {
	open $self->{f}{handle}, '<:scalar', \$filelist->[$idx]{text};
    } else {
	open $self->{f}{handle}, '<', $filename;
    }

    # and spin on to where we left off (usually byte 0)
    seek $self->{f}{handle}, $filelist->[$idx]{pos}, 0;
}

=head2 fpush

Inserts a single file into the processing queue, with processing to
transfer immediately and return upon completion.

    $l->fpush("filename");

or

    $l->fpush( { name   => 'fauxfile',
                 scalar => 1,
                 text   => $string } );

=cut

sub fpush {
    my ($self,$file) = @_;
    my $idx = $self->{f}{idx};
    my $os  = $idx - 1;
    my $pos = $self->{f}{list}[$idx]{pos};

    # set pos on current file, correcting for the lookahead character
    do { use bytes;
	 $self->{f}{list}[$idx]{pos} = 
	   $pos - length($self->{l}{char});
    };

    # construct the fileinfo hash
    my %finfo = ( pos => 0,
		  line => 1,
		  par => $self->{f}{list}[$idx]{name},
		  pline => $self->{f}{list}[$idx]{line} );

    # now splice in the new file and back up the filelist pointer by one
    unshift @{$self->{f}{list}},  filehash($file, %finfo);
    $self->{f}{idx}--;

    # open the push'd file and get the new lookahead char
    $self->fopen;
    $self->lookahead;
}


=head2 fdupecheck

Scans the filelist for duplicate files. Called by L</fopen>.

Returns 1 if a dupe is found; zero otherwise.

=cut

sub fdupecheck {
    my ($self, $filename, $filelist) = @_;
    my $idx = $self->{f}{idx};

    return 0 if (defined $filelist->[$idx]{md5});

    my $scalar = $filelist->[$idx]{scalar};
    my $md5;
    my $i = -1;

    if ($scalar) {
        $md5 = md5_hex($filelist->[$idx]{text});
    } else {
        open MD5FILE, '<', $filename;
        binmode(MD5FILE);
        $md5 = Digest::MD5->new->addfile(*MD5FILE)->hexdigest;
        close MD5FILE;
    }

    foreach my $f (@{$filelist}) {
        $i++;
        next if ($i == $idx);
        next unless (defined $f->{md5});
        return 1 if ($f->{md5} eq $md5);
    }

    $filelist->[$idx]{md5} = $md5;
    return 0;
}


=head1 AUTHOR

Shawn Boyette, C<< <mdxi@cpan.org> >>

=head1 BUGS

Please report any bugs or feature requests at
L<http://carrot.googlecode.com>.  I will be notified, and then you'll
automatically be notified of progress on your bug as I make changes.

=head1 COPYRIGHT & LICENSE

Copyright 2004-2008 Shawn Boyette

All rights reserved.

Redistribution and use in source and binary forms, with or without
modification, are permitted provided that the following conditions are
met:

    * Redistributions of source code must retain the above copyright
      notice, this list of conditions and the following disclaimer.

    * Redistributions in binary form must reproduce the above
      copyright notice, this list of conditions and the following
      disclaimer in the documentation and/or other materials provided
      with the distribution.

    * Neither the name of the <ORGANIZATION> nor the names of its
      contributors may be used to endorse or promote products derived
      from this software without specific prior written permission.

THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.

=cut

1; # End of Firepear::Carrot::Lexer
